home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / MacHaskell 2.2 / parser / typedecl-parser.scm < prev   
Encoding:
Text File  |  1994-09-27  |  6.0 KB  |  205 lines  |  [TEXT/CCL2]
  1. ;;; File: parser/typedecl-parser     Author: John
  2.  
  3. (define (parse-type-decl interface?)
  4.  (save-parser-context
  5.   (let* ((sig (parse-signature))
  6.      (contexts (signature-context sig))
  7.      (simple (signature-type sig))
  8.      (deriving '())
  9.      (constrs '()))
  10.     ;; #t = builtins ([] (,,) ->) not allowed
  11.     (check-simple simple '#t "type declaration")
  12.     (let ((annotations (parse-constr-annotations)))
  13.      (token-case
  14.       (= (setf constrs (parse-constrs))
  15.      (token-case
  16.       (|deriving|
  17.        (setf deriving
  18.          (token-case
  19.          (\( 
  20.           (token-case
  21.            (\) '())
  22.            (else (parse-class-list))))
  23.          (tycon (list (class->ast)))
  24.          (else (signal-invalid-syntax "a deriving clause")))))))
  25.       (else
  26.        (when (not interface?)
  27.      (signal-missing-constructors))))
  28.     (make data-decl (context contexts) (simple simple)
  29.             (constrs constrs) (deriving deriving)
  30.             (annotations annotations))))))
  31.  
  32. (define (signal-missing-constructors)
  33.   (parser-error 'missing-constructors
  34.         "Data type definition requires constructors"))
  35.  
  36. (define (check-simple simple fresh? where)
  37.   (when (not (tycon? simple))
  38.     (signal-not-simple where))
  39.   (when (and fresh? (not (eq? (tycon-def simple) *undefined-def*)))
  40.     (signal-not-simple where))
  41.   (let ((tyvars (map (lambda (arg)
  42.                (when (not (tyvar? arg))
  43.                  (signal-not-simple where))
  44.                (tyvar-name arg))
  45.              (tycon-args simple))))
  46.     (when (not (null? (find-duplicates tyvars)))
  47.       (signal-unique-tyvars-required))))
  48.  
  49. (define (signal-unique-tyvars-required)
  50.   (parser-error 'unique-tyvars-required
  51.         "Duplicate type variables appear in simple."))
  52.  
  53. (define (signal-not-simple where)
  54.   (parser-error 'not-simple "Simple type required in ~a." where))
  55.  
  56. (define (parse-constrs)
  57.   (let ((constr (parse-constr)))
  58.     (token-case
  59.      (\| (cons constr (parse-constrs)))
  60.      (else (list constr)))))
  61.  
  62. (define (parse-constr)
  63.  (save-parser-context
  64.   (let ((saved-excursion (save-scanner-state)))
  65.     (token-case
  66.      (consym/paren
  67.       (parse-prefix-constr))
  68.      (else
  69.       (let ((type1 (parse-btype))
  70.         (anns (parse-constr-annotations)))
  71.     (token-case
  72.      (conop
  73.       (parse-infix-constr (tuple type1 anns)))
  74.      (else
  75.       (restore-excursion saved-excursion)
  76.       (parse-prefix-constr)))))))))
  77.  
  78. (define (parse-prefix-constr)
  79.   (token-case
  80.    (con
  81.     (let* ((con (con->ast))
  82.        (types (parse-constr-type-list)))
  83.       (make constr (constructor con) (types types))))
  84.    (else
  85.     (signal-missing-token "<con>" "constrs list"))))
  86.  
  87. (define (parse-constr-type-list)
  88.   (token-case
  89.     (atype-start
  90.      (let* ((atype (parse-atype))
  91.         (anns (parse-constr-annotations)))
  92.        (cons (tuple atype anns)
  93.          (parse-constr-type-list))))
  94.     (else '())))
  95.  
  96. (define (parse-infix-constr t+a1)
  97.   (let* ((con (conop->ast))
  98.      (type2 (parse-btype))
  99.      (anns (parse-constr-annotations)))
  100.     (make constr (constructor con) (types (list t+a1 (tuple type2 anns))))))
  101.  
  102. (define (parse-class-list)
  103.   (token-case
  104.    (tycon (let ((class (class->ast)))
  105.          (token-case
  106.           (\, (cons class (parse-class-list)))
  107.           (\) (list class))
  108.           (else (signal-missing-token "`)' or `,'" "deriving clause")))))
  109.    (else (signal-missing-token "<tycon>" "deriving clause"))))
  110.  
  111. (define (parse-constr-annotations)
  112.   (token-case
  113.    ((begin-annotation no-advance)
  114.     (let ((annotations (parse-annotations 'constructor)))
  115.       (append annotations (parse-constr-annotations))))
  116.    (else '())))
  117.  
  118. (define (parse-synonym-decl)
  119.  (save-parser-context
  120.   (let* ((sig (parse-signature))
  121.      (contexts (signature-context sig))
  122.      (simple (signature-type sig)))
  123.     (check-simple simple '#t "type synonym declaration")
  124.     (when (not (null? contexts))
  125.       (signal-no-context-in-synonym))
  126.     (require-token = (signal-missing-token "`='" "type synonym declaration"))
  127.     (let ((body (parse-type)))
  128.       (make synonym-decl (simple simple) (body body))))))
  129.  
  130. (define (signal-no-context-in-synonym)
  131.   (parser-error 'no-context-in-synonym
  132.         "Context is not permitted in type synonym declaration."))
  133.  
  134. (define (parse-class-decl)
  135.  (save-parser-context
  136.   (let ((supers (parse-optional-context)))
  137.     (token-case
  138.      (tycon
  139.       (let ((class (class->ast)))
  140.     (token-case
  141.      (tyvar
  142.       (let* ((class-var (token->symbol))
  143.          (decls (parse-where-decls)))
  144.         (make class-decl (class class) (super-classes supers)
  145.                      (class-var class-var) (decls decls))))
  146.      (else
  147.       (signal-missing-token "<tyvar>" "class declaration")))))
  148.      (else (signal-missing-token "<tycon>" "class declaration"))))))
  149.  
  150. (define (parse-instance-decl interface? deriving?)
  151.  (save-parser-context
  152.   (let ((contexts (parse-optional-context))
  153.     (decls '()))
  154.     (token-case
  155.      (tycon
  156.       (let* ((class (class->ast))
  157.          (simple (parse-type)))
  158.     (when (not interface?)
  159.        (setf decls (parse-where-decls)))
  160.     (if deriving?
  161.         (unless (tyvar? simple)
  162.            (signal-missing-token "<tyvar>"
  163.                    "instance within deriving declaration"))
  164.         (check-simple simple '#f "instance declaration"))
  165.     (make instance-decl (context contexts) (class class)
  166.                         (simple simple) (decls decls))))
  167.      (else (signal-missing-token "<tycon>" "instance declaration"))))))
  168.  
  169.  
  170. ;;; This is a Yale extension for derived instances
  171.  
  172. ;;; deriving [Context =>] D a where
  173. ;;;  instance i1
  174. ;;;  instance i2 ...
  175.  
  176. (define (parse-deriving-decl)
  177.   (save-parser-context
  178.    (let* ((sig (parse-signature))
  179.       (contexts (signature-context sig))
  180.       (simple (signature-type sig))
  181.       (inst-decls '()))
  182.      (check-simple simple '#t "deriving declaration")
  183.      (token-case
  184.       (|where|
  185.     (setf inst-decls (parse-instance-decl-list)))
  186.       (else (signal-missing-token "where" "deriving declaration")))
  187.      (make deriving-decl (constraints contexts) (simple simple)
  188.                      (inst-decls inst-decls)))))
  189.      
  190. (define (parse-instance-decl-list)
  191.   (start-layout (function parse-instance-list-1)))
  192.  
  193. (define (parse-instance-list-1 in-layout?)
  194.   (token-case
  195.    (|instance|
  196.     (let ((idecl (parse-instance-decl '#f '#t)))
  197.       (token-case
  198.        (\; (cons idecl (parse-instance-list-1 in-layout?)))
  199.        (else (close-layout in-layout?)
  200.          (list idecl)))))
  201.    (else
  202.     (close-layout in-layout?)
  203.     '())))
  204.           
  205.